home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.004 / xemacs-1 / xemacs-19.13 / src / epoch.c < prev    next >
Encoding:
C/C++ Source or Header  |  1995-08-15  |  30.4 KB  |  1,169 lines
  1. /* Epoch functionality.
  2.    Copyright (C) 1985-1995 Free Software Foundation.
  3.  
  4. This file is part of XEmacs.
  5.  
  6. XEmacs is free software; you can redistribute it and/or modify it
  7. under the terms of the GNU General Public License as published by the
  8. Free Software Foundation; either version 2, or (at your option) any
  9. later version.
  10.  
  11. XEmacs is distributed in the hope that it will be useful, but WITHOUT
  12. ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  13. FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  14. for more details.
  15.  
  16. You should have received a copy of the GNU General Public License
  17. along with XEmacs; see the file COPYING.  If not, write to the Free
  18. Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.  */
  19.  
  20. /* Synched up with: Not in FSF. */
  21.  
  22. #include <config.h>
  23. #include "lisp.h"
  24. #include "frame-x.h"
  25. #include "objects-x.h"
  26. #include "events.h"
  27.  
  28. Lisp_Object Qx_property_change, Qx_client_message, Qx_map, Qx_unmap;
  29. Lisp_Object Vepoch_event, Vepoch_event_handler;
  30.  
  31. Lisp_Object
  32. make_xresource (XID xid, Atom type)
  33. {
  34.   struct Lisp_X_Resource *xr =
  35.     alloc_lcrecord (sizeof (struct Lisp_X_Resource), lrecord_x_resource);
  36.   Lisp_Object val;
  37.  
  38.   xr->xid = xid;
  39.   xr->type = type;
  40.   XSETXRESOURCE (val, xr);
  41.  
  42.   return val;
  43. }
  44.  
  45. /*
  46.  * Epoch equivalent:  epoch::intern-atom
  47.  */
  48. DEFUN ("x-intern-atom", Fx_intern_atom, Sx_intern_atom, 1, 1, 0,
  49.  "Convert a STRING or SYMBOL into an atom and return as an XRESOURCE.")
  50.      (name)
  51.      Lisp_Object name;
  52. {
  53.   /* !!#### This function has not been Mule-ized */
  54.   Atom atom;
  55.   char *data;
  56.  
  57.   if (SYMBOLP (name))
  58.     data = (char *) string_data (XSYMBOL (name)->name);
  59.   else
  60.     {
  61.       CHECK_STRING (name, 0);
  62.       data = (char *) string_data (XSTRING (name));
  63.     }
  64.  
  65.   atom = XInternAtom (FIXME_DISPLAY, data, False);
  66.  
  67.   return make_xresource (atom, XA_ATOM);
  68. }
  69.  
  70. /*
  71.  * Epoch equivalent:  epoch::unintern-atom
  72.  */
  73. DEFUN ("x-atom-name", Fx_atom_name, Sx_atom_name, 1, 1, 0,
  74.   "Return the name of an X atom resource as a string.")
  75.      (atom)
  76.      Lisp_Object atom;
  77. {
  78.   /* !!#### This function has not been Mule-ized */
  79.   char *atom_name;
  80.   Lisp_Object val;
  81.  
  82.   CHECK_XRESOURCE (atom, 0);
  83.   if (XXRESOURCE (atom)->type != XA_ATOM)
  84.     error ("Resource is not an atom");
  85.  
  86.   atom_name = XGetAtomName (FIXME_DISPLAY, XXRESOURCE (atom)->xid);
  87.  
  88.   if (atom_name)
  89.     {
  90.       val = build_string (atom_name);
  91.       xfree (atom_name);
  92.     }
  93.   else
  94.     val = Qnil;
  95.  
  96.   return val;
  97. }
  98.  
  99. /*
  100.  * Epoch equivalent:  epoch::string-to-resource
  101.  */
  102. DEFUN ("x-string-to-x-resource", Fx_string_to_x_resource,
  103.        Sx_string_to_x_resource, 2, 3, 0,
  104.   "Convert a numeric STRING to an XRESOURCE.\n\
  105. STRING is assumed to represent a 32-bit numer value. XRESOURCE must be\n\
  106. an X atom.  Optional BASE argument should be a number between 2 and 36,\n\
  107. specifying the base for converting STRING.")
  108.      (string, type, base)
  109.      Lisp_Object string, type, base;
  110. {
  111.   /* !!#### This function has not been Mule-ized */
  112.   XID xid;
  113.   struct Lisp_X_Resource *xr;
  114.   char *ptr;
  115.   int b;
  116.  
  117.   CHECK_STRING (string, 0);
  118.   CHECK_XRESOURCE (type, 0);
  119.  
  120.   if (EQ (base, Qnil))
  121.     b = 0;
  122.   else
  123.     {
  124.       CHECK_INT (base, 0);
  125.       b = XINT (base);
  126.       check_int_range (b, 2, 36);
  127.     }
  128.  
  129.   if (XXRESOURCE (type)->type != XA_ATOM)
  130.     error ("Resource must be an atom");
  131.   xr = XXRESOURCE (type);
  132.  
  133.   xid = (XID) strtol ((CONST char*) string_data (XSTRING (string)), &ptr, b);
  134.  
  135.   return ((ptr == (char *) string_data (XSTRING (string)))
  136.       ? Qnil
  137.       : make_xresource (xid, xr->xid));
  138. }
  139.  
  140. /*
  141.  * Epoch equivalent:  epoch::resource-to-type
  142.  */
  143. DEFUN ("x-resource-to-type", Fx_resource_to_type, Sx_resource_to_type, 1, 1, 0,
  144.   "Return an x-resource of type ATOM whose value is the type of the argument")
  145.      (resource)
  146.      Lisp_Object resource;
  147. {
  148.   struct Lisp_X_Resource *xr;
  149.  
  150.   CHECK_XRESOURCE (resource, 0);
  151.   xr = XXRESOURCE (resource);
  152.  
  153.   return make_xresource (xr->type, XA_ATOM);
  154. }
  155.  
  156. /* internal crap stolen from Epoch */
  157. static char LongToStringBuffer[33]; /* can't have statics inside functions! */
  158. char *
  159. long_to_string (unsigned long n, unsigned int base)
  160. {
  161.   /* !!#### This function has not been Mule-ized */
  162.   char *digit = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ";
  163.   char *s = LongToStringBuffer + 32; /* at most 33 characters in binary */
  164.  
  165.   *s = 0;            /* terminate */
  166.   while (n)            /* something there */
  167.     {
  168.     *--s = digit[n % base];        /* store bottom digit */
  169.     n /= base;            /* shift right */
  170.     }
  171.   if (*s == 0) *--s = '0';        /* in case nothing was put in string */
  172.   return s;
  173. }
  174.  
  175. /*
  176.  * Epoch equivalent:  epoch::resource-to-string
  177.  */
  178. DEFUN ("x-resource-to-string", Fx_resource_to_string, Sx_resource_to_string,
  179.        1, 2, 0,
  180.   "Convert the xid of RESOURCE to a numeric string.\n\
  181. Optional BASE specifies the base for the conversion (2..36 inclusive)")
  182.      (resource, base)
  183.      Lisp_Object resource, base;
  184. {
  185.   /* !!#### This function has not been Mule-ized */
  186.   int cbase = 10;
  187.  
  188.   CHECK_XRESOURCE (resource, 0);
  189.   if (!NILP (base))
  190.     {
  191.       CHECK_INT (base, 0);
  192.       cbase = XINT (base);
  193.       check_int_range (cbase, 2, 36);
  194.     }
  195.  
  196.   return build_string (long_to_string (XXRESOURCE (resource)->xid, cbase));
  197. }
  198.  
  199. /*
  200.  * Epoch equivalent:  epoch::xid-of-frame
  201.  *
  202.  * This differs from x-window-id in xfns.c in that its return value is an
  203.  * x-resource rather than a string.
  204.  */
  205. DEFUN ("x-id-of-frame", Fx_id_of_frame, Sx_id_of_frame, 0, 1, 0,
  206.   "Return ID of FRAME as an x-resource, or nil on error.")
  207.      (frame)
  208.      Lisp_Object frame;
  209. {
  210.   struct frame *f = get_x_frame (frame);
  211.  
  212.   return make_xresource (XtWindow (FRAME_X_SHELL_WIDGET (f)), XA_WINDOW);
  213. }
  214.  
  215. /*
  216.  * Epoch equivalent:  epoch::query-tree
  217. */
  218. DEFUN ("x-query-tree", Fx_query_tree, Sx_query_tree, 0, 1, 0,
  219.   "Return the portion of the window tree adjacent to FRAME.\n\
  220. Return value is the list ( ROOT PARENT . CHILDREN ).  The FRAME arg\n\
  221. can either be a frame object or an x-resource of type window.")
  222.      (frame)
  223.      Lisp_Object frame;
  224. {
  225.   Window win;
  226.   Window root, parent, *children;
  227.   unsigned int count;
  228.   int retval;
  229.   Lisp_Object val;
  230.  
  231.   if (XRESOURCEP (frame))
  232.     {
  233.       if (XXRESOURCE (frame)->type != XA_WINDOW)
  234.     error ("Frame resource must be of type WINDOW");
  235.       win = XXRESOURCE (frame)->xid;
  236.     }
  237.   else
  238.     {
  239.       win = XXRESOURCE (Fx_id_of_frame (frame))->xid;
  240.     }
  241.  
  242.   retval =
  243.     XQueryTree (FIXME_DISPLAY, win, &root, &parent, &children, &count);
  244.  
  245.   /* Thank you, X-Consortium. XQueryTree doesn't return Success like everyone
  246.    * else, it returns 1. (Success is defined to be 0 in the standard header
  247.    * files)
  248.    */
  249.   if (!retval) return Qnil;
  250.  
  251.   val = Qnil;
  252.   while (count)
  253.     val = Fcons (make_xresource (children[--count], XA_WINDOW), val);
  254.  
  255.   xfree (children);
  256.  
  257.   return Fcons (make_xresource (root, XA_WINDOW),
  258.         Fcons ((parent
  259.             ? make_xresource (parent, XA_WINDOW)
  260.             : Qnil),
  261.                val));
  262. }
  263.  
  264. /* more internal crap stolen from Epoch */
  265.  
  266. static void
  267. verify_vector_has_consistent_type (Lisp_Object vector)
  268. {
  269.   int i;            /* vector index */
  270.   XID rtype;            /* Xresource type (if vector of Xresources) */
  271.   int length;            /* vector length */
  272.   struct Lisp_Vector *v = XVECTOR (vector);
  273.   Lisp_Object *element;
  274.   Lisp_Object sample;
  275.   Lisp_Object type_obj;        /* base type of vector elements */
  276.  
  277.   sample = v->contents[0];
  278.   type_obj = sample;
  279.   if (XRESOURCEP (sample))
  280.     rtype = XXRESOURCE (sample)->type;
  281.   length = v->size;
  282.   element = v->contents;
  283.  
  284.   for (i = 1; i < length; ++i, ++element)
  285.     {
  286.       QUIT;
  287.       if ((XTYPE (*element) != XTYPE (type_obj))
  288.       || (LRECORDP (type_obj) &&
  289.           (XRECORD_LHEADER (*element)->implementation !=
  290.            XRECORD_LHEADER (type_obj)->implementation))
  291.       || (XRESOURCEP (type_obj) && rtype != XXRESOURCE (*element)->type))
  292.     error ("Vector has inconsistent types");
  293.     }
  294. }
  295.  
  296. static void
  297. verify_list_has_consistent_type (Lisp_Object list)
  298. {
  299.   Lisp_Object type_obj;
  300.   XID rtype;            /* Xresource type (if vector of Xresources) */
  301.   Lisp_Object temp = Fcar (list);
  302.  
  303.   type_obj = temp;
  304.   if (XRESOURCEP (temp))
  305.     rtype = XXRESOURCE (temp)->type;
  306.   list = Fcdr (list);
  307.  
  308.   for ( ; !NILP (list) ; list = Fcdr (list))
  309.     {
  310.       QUIT;
  311.       temp = Fcar (list);
  312.       if ((XTYPE (temp) != XTYPE (type_obj))
  313.       || (LRECORDP (type_obj) &&
  314.           (XRECORD_LHEADER (temp)->implementation !=
  315.            XRECORD_LHEADER (type_obj)->implementation))
  316.       || (XRESOURCEP (type_obj) && rtype != XXRESOURCE (temp)->type))
  317.     error ("List has inconsistent types");
  318.     }
  319. }
  320.  
  321. #define BYTESIZE 8
  322. /* 16 bit types */
  323. typedef short int int16;
  324. typedef short unsigned int uint16;
  325.  
  326. /* the Calculate functions return allocated memory that must be free'd.
  327.    I tried to use alloca, but that fails. Sigh.
  328. */
  329. static void *
  330. calculate_vector_property (Lisp_Object vector, unsigned long *count,
  331.                Atom *type, int *format)
  332. {
  333.   /* !!#### This function has not been Mule-ized */
  334.   int length;
  335.   unsigned int size,tsize;
  336.   int i;
  337.   struct Lisp_Vector *v;
  338.   void *addr;
  339.  
  340.   v = XVECTOR (vector);
  341.   *count = length = v->size;
  342.  
  343.   switch (XTYPE (v->contents[0]))
  344.     {
  345.     case Lisp_Int:
  346.       *type = XA_INTEGER;
  347.       if (*format != 8 && *format != 16) *format = 32;
  348.       size = *format * length;
  349.       addr = (void *) xmalloc (size);
  350.       for ( i = 0 ; i < length ; ++i )
  351.     switch (*format)
  352.       {
  353.       case 32 : ((int *)addr)[i] = XINT (v->contents[i]); break;
  354.       case 16 : ((int16 *)addr)[i] = XINT (v->contents[i]); break;
  355.       case 8 : ((char *)addr)[i] = XINT (v->contents[i]); break;
  356.       }
  357.       break;
  358.  
  359.     case Lisp_Record:
  360.       if (XRESOURCEP (v->contents[0]))
  361.     {
  362.       size = BYTESIZE * sizeof (XID) * length;
  363.       *format = BYTESIZE * sizeof (XID);
  364.       *type = XXRESOURCE (v->contents[0])->type;
  365.       addr = (void *) xmalloc (size);
  366.       for ( i = 0 ; i < length ; ++i )
  367.         ( (XID *) addr) [i] = XXRESOURCE (v->contents[i])->xid;
  368.     }
  369.       break;
  370.  
  371.     case Lisp_String:
  372.       *format = BYTESIZE * sizeof (char);
  373.       *type = XA_STRING;
  374.       for ( i=0, size=0 ; i < length ; ++i )
  375.     size += string_length (XSTRING (v->contents[i])) + 1; /* include null */
  376.       addr = (void *) xmalloc (size);
  377.       *count = size;
  378.       for ( i = 0 , size = 0 ; i < length ; ++i )
  379.     {
  380.       tsize = string_length (XSTRING (v->contents[i])) + 1;
  381.       memmove (((char *) addr), string_data (XSTRING (v->contents[i])), tsize);
  382.       size += tsize;
  383.     }
  384.       break;
  385.  
  386.     default:
  387.       error ("Invalid type for conversion");
  388.     }
  389.   return addr;
  390. }
  391.  
  392. static void *
  393. calculate_list_property (Lisp_Object list, unsigned long *count,
  394.              Atom *type, int *format)
  395. {
  396.   /* !!#### This function has not been Mule-ized */
  397.   int length;
  398.   unsigned int size, tsize;
  399.   int i;
  400.   Lisp_Object tlist,temp;
  401.   void *addr;
  402.  
  403.   *count = length = XINT (Flength (list));
  404.  
  405.   switch (XTYPE (Fcar (list)))
  406.     {
  407.     case Lisp_Int:
  408.       *type = XA_INTEGER;
  409.       if (*format != 8 && *format != 16) *format = 32;
  410.       size = *format * length;
  411.       addr = (void *) xmalloc (size);
  412.       for ( i = 0 ; i < length ; ++i, list = Fcdr (list))
  413.     switch (*format)
  414.       {
  415.       case 32 : ((int *)addr)[i] = XINT (Fcar (list)); break;
  416.       case 16 : ((int16 *)addr)[i] = XINT (Fcar (list)); break;
  417.       case 8 : ((char *)addr)[i] = XINT (Fcar (list)); break;
  418.       }
  419.       break;
  420.  
  421.     case Lisp_Record:
  422.       if (XRESOURCEP (Fcar (list)))
  423.     {
  424.       size = BYTESIZE * sizeof (XID) * length;
  425.       *format = BYTESIZE * sizeof (XID);
  426.       *type = XXRESOURCE (Fcar (list))->type;
  427.       addr = (void *) xmalloc (size);
  428.       for ( i = 0 ; i < length ; ++i, list = Fcdr (list))
  429.         ((XID *)addr)[i] = XXRESOURCE (Fcar (list))->xid;
  430.     }
  431.       break;
  432.  
  433.     case Lisp_String:
  434.       *format = BYTESIZE * sizeof (char);
  435.       *type = XA_STRING;
  436.       for ( i=0, size=0 , tlist=list ; i < length ; ++i, tlist = Fcdr (tlist) )
  437.     size += string_length (XSTRING (Fcar (tlist))) + 1; /* include null */
  438.       addr = (void *) xmalloc (size);
  439.       *count = size;
  440.       for ( i=0, size=0, tlist=list ; i < length  ; ++i , tlist = Fcdr (tlist) )
  441.     {
  442.       temp = Fcar (tlist);
  443.       tsize = string_length (XSTRING (temp)) + 1;
  444.       memmove (((char *) addr), string_data (XSTRING (temp)), tsize);
  445.       size += tsize;
  446.     }
  447.       break;
  448.  
  449.     default:
  450.       error ("Invalid type for conversion");
  451.     }
  452.   return addr;
  453. }
  454.  
  455. /* Returns whether the conversion was successful or not */
  456. static int
  457. convert_elisp_to_x (Lisp_Object value, void **addr, unsigned long *count,
  458.             Atom *type, int *format, int *free_storage)
  459. {
  460.   /* !!#### This function has not been Mule-ized */
  461.   if (VECTORP (value))
  462.     verify_vector_has_consistent_type (value);
  463.   else if (CONSP (value))
  464.     verify_list_has_consistent_type (value);
  465.  
  466.   *free_storage = 0;
  467.   switch (XTYPE (value))
  468.     {
  469.     case Lisp_String:
  470.       *format = BYTESIZE;
  471.       *type = XA_STRING;
  472.       *count = strlen ((CONST char *) string_data (XSTRING (value)))+1;
  473.       *addr = (void *) string_data (XSTRING (value));
  474.       break;
  475.  
  476.     case Lisp_Int:
  477.       *type = XA_INTEGER;
  478.       *count = 1;
  479.       *free_storage = 1;
  480.       *addr = (void *) xmalloc (sizeof (int));
  481.       /* This is ugly -
  482.        * we have to deal with the possibility of different formats
  483.        */
  484.       switch (*format)
  485.     {
  486.     default :
  487.     case 32 : *format = 32; *((int *)(*addr)) = XINT (value); break;
  488.     case 16 : *((int16 *)(*addr)) = XINT (value); break;
  489.     case 8 :  *((char *)(*addr)) = XINT (value); break;
  490.     }
  491.       break;
  492.  
  493.     case Lisp_Record:
  494.       if (XRESOURCEP (value))
  495.     {
  496.       *format = sizeof (XID) * BYTESIZE;
  497.       *type = XXRESOURCE (value)->type;
  498.       *count = 1;
  499.       *addr = (void *) & (XXRESOURCE (value)->xid);
  500.     }
  501.       break;
  502.  
  503.     case Lisp_Cons:
  504.       *addr = calculate_list_property (value,count,type,format);
  505.       *free_storage = 1;    /* above allocates storage */
  506.       break;
  507.  
  508.     case Lisp_Vector:
  509.       *addr = calculate_vector_property (value,count,type,format);
  510.       *free_storage = 1;    /* above allocates storage */
  511.       break;
  512.  
  513.     default :
  514.       error ("Improper type for conversion");
  515.     }
  516.  
  517.   return 1;
  518. }
  519.  
  520. static Lisp_Object
  521. format_size_hints (XSizeHints *hints)
  522. {
  523.   Lisp_Object result;
  524.   struct Lisp_Vector *v;
  525.  
  526.   result = Fmake_vector (make_number (6), Qnil);
  527.   v = XVECTOR (result);
  528.  
  529.   /* ugly but straightforward - just step through the members and flags
  530.    * and stick in the ones that are there
  531.    */
  532.   if (hints->flags & (PPosition|USPosition))
  533.     v->contents[0] = Fcons (make_number (hints->x), make_number (hints->y));
  534.   if (hints->flags & (PSize|USSize))
  535.     v->contents[1] = Fcons (make_number (hints->width),
  536.                make_number (hints->height));
  537.   if (hints->flags & PMinSize)
  538.     v->contents[2] = Fcons (make_number (hints->min_width),
  539.                make_number (hints->min_height));
  540.   if (hints->flags & PMaxSize)
  541.     v->contents[3] = Fcons (make_number (hints->max_width),
  542.                make_number (hints->max_height));
  543.   if (hints->flags & PResizeInc)
  544.         v->contents[4] = Fcons (make_number (hints->width_inc),
  545.                                make_number (hints->height_inc));
  546.   if (hints->flags & PAspect)
  547.     v->contents[5] = Fcons (make_number (hints->min_aspect.x),
  548.                Fcons (make_number (hints->min_aspect.y),
  549.                  Fcons (make_number (hints->max_aspect.x),
  550.                        make_number (hints->max_aspect.y))));
  551.  
  552.   return result;
  553. }
  554.  
  555. static Lisp_Object
  556. format_string_property (char *buffer, unsigned long count)
  557. {
  558.   /* !!#### This function has not been Mule-ized */
  559.   Lisp_Object value = Qnil;        /* data */
  560.   Lisp_Object temp;            /* temp value holder */
  561.   int len;                /* length of current string */
  562.   char *strend;
  563.  
  564.   while (count)
  565.     {
  566.       strend = memchr (buffer, 0, (int) count);
  567.       len = strend ? strend - buffer : count;
  568.       if (len)
  569.     {
  570.       temp = make_string ((Bufbyte *) buffer, len);
  571.       value = Fcons (temp, value);
  572.     }
  573.       buffer = strend + 1;    /* skip null, or leaving loop if no null */
  574.       count -= len + !!strend;
  575.     }
  576.  
  577.   return (NILP (Fcdr (value))
  578.       ? Fcar (value)
  579.       : Fnreverse (value));
  580. }
  581.  
  582. static Lisp_Object
  583. format_integer_32_property (long *buff, unsigned long count)
  584. {
  585.   Lisp_Object value = Qnil;    /* return value */
  586.   while (count)
  587.     value = Fcons (make_number (buff[--count]), value);
  588.  
  589.   return (NILP (Fcdr (value))
  590.       ? Fcar (value)
  591.       : value);
  592. }
  593.  
  594. static Lisp_Object
  595. format_integer_16_property (int16 *buff, unsigned long count)
  596. {
  597.   Lisp_Object value = Qnil;    /* return value */
  598.  
  599.   while (count)
  600.     value = Fcons (make_number (buff[--count]), value);
  601.  
  602.   return (NILP (Fcdr (value))
  603.       ? Fcar (value)
  604.       : value);
  605. }
  606.  
  607. static Lisp_Object
  608. format_integer_8_property (char *buff, unsigned long count)
  609. {
  610.   Lisp_Object value = Qnil;    /* return value */
  611.  
  612.   while (count)
  613.     value = Fcons (make_number (buff[--count]), value);
  614.  
  615.   return (NILP (Fcdr (value))
  616.       ? Fcar (value)
  617.       : value);
  618. }
  619.  
  620. static Lisp_Object
  621. format_integer_property (void *buff, unsigned long count, int format)
  622. {
  623.   switch (format)
  624.     {
  625.     case 8:
  626.       return format_integer_8_property ((char *) buff, count);
  627.       break;
  628.     case 16:
  629.       return format_integer_16_property ((int16 *) buff, count);
  630.       break;
  631.     case 32:
  632.       return format_integer_32_property ((long *) buff, count);
  633.       break;
  634.     default:
  635.       return Qnil;
  636.     }
  637. }
  638.  
  639. static Lisp_Object
  640. format_cardinal_32_property (unsigned long *buff, unsigned long count)
  641. {
  642.   Lisp_Object value = Qnil;    /* return value */
  643.  
  644.   while (count)
  645.     value = Fcons (make_number (buff[--count]), value);
  646.  
  647.   return (NILP (Fcdr (value))
  648.       ? Fcar (value)
  649.       : value);
  650. }
  651.  
  652. static Lisp_Object
  653. format_cardinal_16_property (uint16 *buff, unsigned long count)
  654. {
  655.   Lisp_Object value = Qnil;    /* return value */
  656.  
  657.   while (count)
  658.     value = Fcons (make_number (buff[--count]), value);
  659.  
  660.   return (NILP (Fcdr (value))
  661.       ? Fcar (value)
  662.       : value);
  663. }
  664.  
  665. static Lisp_Object
  666. format_cardinal_8_property (unsigned char *buff, unsigned long count)
  667. {
  668.   Lisp_Object value = Qnil;    /* return value */
  669.  
  670.   while (count)
  671.     value = Fcons (make_number (buff[--count]), value);
  672.  
  673.   return (NILP (Fcdr (value))
  674.       ? Fcar (value)
  675.       : value);
  676. }
  677.  
  678. static Lisp_Object
  679. format_cardinal_property (void *buff, unsigned long count, int format)
  680. {
  681.   switch (format)
  682.     {
  683.     case 8:
  684.       return format_cardinal_8_property ((unsigned char *) buff, count);
  685.       break;
  686.     case 16:
  687.       return format_cardinal_16_property ((uint16 *) buff, count);
  688.       break;
  689.     case 32:
  690.       return format_cardinal_32_property ((unsigned long *) buff, count);
  691.     default:
  692.       return Qnil;
  693.     }
  694. }
  695.  
  696. static Lisp_Object
  697. format_unknown_property (void *buff, unsigned long count, Atom type,
  698.              int format)
  699. {
  700.   Lisp_Object value = Qnil;    /* return value */
  701.  
  702.   switch (format)
  703.     {
  704.     case 32:
  705.       {
  706.     XID *xid = (XID *) buff;
  707.     int non_zero = 0;
  708.     while (count--)
  709.       if (non_zero || xid[count])
  710.         {
  711.           value = Fcons (make_xresource (xid[count],type), value);
  712.           non_zero = 1;
  713.         }
  714.       }
  715.       break;
  716.     }
  717.  
  718.   return (NILP (Fcdr (value))
  719.       ? Fcar (value)
  720.       : value);
  721. }
  722.  
  723. static Lisp_Object
  724. convert_x_to_elisp (void *buffer, unsigned long count, Atom type, int format)
  725. {
  726.   /* !!#### This function has not been Mule-ized */
  727.   Lisp_Object value = Qnil;
  728.  
  729.   switch (type)
  730.     {
  731.     case None:
  732.       value = Qnil;
  733.       break;
  734.     case XA_STRING:
  735.       value = format_string_property (buffer, count);
  736.       break;
  737.     case XA_INTEGER:
  738.       value = format_integer_property ((long *) buffer, count, format);
  739.       break;
  740.     case XA_CARDINAL:
  741.       value = format_cardinal_property ((unsigned long *) buffer,
  742.                     count, format);
  743.       break;
  744.     case XA_WM_SIZE_HINTS:
  745.       value = format_size_hints ((XSizeHints *) buffer);
  746.       break;
  747.     default:
  748.       value = format_unknown_property ((void *) buffer, count, type, format);
  749.       break;
  750.     }
  751.  
  752.   return value;
  753. }
  754.  
  755. /* get a property given its atom, display, and window */
  756. Lisp_Object
  757. static raw_get_property (Display *dpy, Window win, Atom prop)
  758. {
  759.   /* !!#### This function has not been Mule-ized */
  760.   Lisp_Object value = Qnil;
  761.   Atom actual_type;
  762.   int actual_format;
  763.   unsigned char *buffer;
  764.   unsigned long count, remaining;
  765.   int zret;
  766.  
  767.   zret = XGetWindowProperty (dpy, win, prop,
  768.                  0L, 1024L, False, AnyPropertyType,
  769.                  &actual_type, &actual_format,
  770.                  &count, &remaining, &buffer);
  771.  
  772.   /* If remaining is set, then there's more of the property to get.
  773.      Let's just do the whole read again, this time with enough space
  774.      to get it all. */
  775.   if (zret == Success && remaining > 0)
  776.     {
  777.       xfree (buffer);
  778.       zret = XGetWindowProperty (dpy, win, prop,
  779.                  0L, 1024L + ((remaining + 3) / 4),
  780.                  False, AnyPropertyType,
  781.                  &actual_type, &actual_format,
  782.                  &count, &remaining, &buffer);
  783.     }
  784.  
  785.   if (zret != Success)
  786.     return Qnil;        /* failed */
  787.  
  788.   value = convert_x_to_elisp (buffer, count, actual_type, actual_format);
  789.  
  790.   xfree (buffer);
  791.   return value;
  792. }
  793.  
  794. /*
  795.  * Epoch equivalent:  epoch::get-property
  796.  */
  797. DEFUN ("x-get-property", Fx_get_property, Sx_get_property, 1, 2, 0,
  798.        "Retrieve the X window property for a frame. Arguments are\n\
  799. PROPERTY: must be a string or an X-resource of type ATOM.\n\
  800. FRAME: (optional) If present, must be a frame object, a frame id, or\n\
  801. and X-resource of type WINDOW. Defaults to the current frame.\n\
  802. Returns the value of the property, or nil if the property couldn't\n\
  803. be retrieved.")
  804.      (name, frame)
  805.      Lisp_Object name, frame;
  806. {
  807.   /* !!#### This function has not been Mule-ized */
  808.   Atom prop = None;
  809.   Display *dpy = FIXME_DISPLAY;
  810.   Window win;
  811.   
  812.   if (XRESOURCEP (frame))
  813.     {
  814.       if (XXRESOURCE (frame)->type != XA_WINDOW)
  815.     error ("Frame resource must be of type WINDOW");
  816.       win = XXRESOURCE (frame)->xid;
  817.     }
  818.   else
  819.     {
  820.       struct frame *f = get_x_frame (frame);
  821.  
  822.       /* We can't use Fx_id_of_frame because it returns the xid of
  823.      the shell widget.  But the property change has to take place
  824.      on the edit widget in order for a PropertyNotify event to
  825.      be generated */
  826.       win = XtWindow (FRAME_X_TEXT_WIDGET (f));
  827. #if 0
  828.       win = XXRESOURCE (Fx_id_of_frame (frame))->xid;
  829. #endif
  830.     }
  831.  
  832.   if (STRINGP (name))
  833.     {
  834.       prop = XInternAtom (dpy, string_data (XSTRING (name)), True);
  835.     }
  836.   else if (XRESOURCEP (name))
  837.     {
  838.       if (XXRESOURCE (name)->type != XA_ATOM)
  839.     error ("Property must be an ATOM X-resource");
  840.       prop = XXRESOURCE (name)->xid;
  841.     }
  842.   else
  843.     error ("Property must be a string or X-resource ATOM");
  844.  
  845.   if (prop == None)
  846.     return Qnil;
  847.  
  848.   /* now we have the atom, let's ask for the property! */
  849.   return raw_get_property (dpy,win,prop);
  850. }
  851.  
  852. static Lisp_Object
  853. raw_set_property (Display *dpy, Window win, Atom prop, Lisp_Object value)
  854. {
  855.   /* !!#### This function has not been Mule-ized */
  856.   Atom actual_type;        /* X type of items */
  857.   int actual_format;        /* size of data items (8,16,32) */
  858.   unsigned long count;        /* Number of data items */
  859.   void* addr;            /* address of data item array */
  860.   int zret;            /* X call return value */
  861.   int free_storage;        /* set if addr points at non-malloc'd store */
  862.  
  863.   actual_format = 0;        /* don't force a particular format */
  864.   convert_elisp_to_x (value, &addr, &count, &actual_type, &actual_format,
  865.               &free_storage);
  866.  
  867.   zret = XChangeProperty (dpy, win, prop, actual_type, actual_format,
  868.               PropModeReplace, (char *) addr, count);
  869.   XFlush (dpy);
  870.  
  871.   if (free_storage)
  872.     xfree (addr);
  873.  
  874.   return value;
  875. }
  876.  
  877. DEFUN ("x-set-property", Fx_set_property, Sx_set_property, 2, 3, 0,
  878.       "Set a named property for a frame. The first argument (required)\n\
  879. is the name of the property. The second is the value to set the propery\n\
  880. to. The third (optional) is the frame, default is\n\
  881. the current frame.")
  882.      (name, value, frame)
  883.      Lisp_Object name, value, frame;
  884. {
  885.   /* !!#### This function has not been Mule-ized */
  886.   Atom prop = None;        /* name of the property */
  887.   Window win;            /* window to put property on */
  888.   Display *dpy = FIXME_DISPLAY;        /* display for window */
  889.  
  890.   if (XRESOURCEP (frame))
  891.     {
  892.       if (XXRESOURCE (frame)->type != XA_WINDOW)
  893.     error ("Frame resource must be of type WINDOW");
  894.       win = XXRESOURCE (frame)->xid;
  895.     }
  896.   else
  897.     {
  898.       struct frame *f = get_x_frame (frame);
  899.  
  900.       /* We can't use Fx_id_of_frame because it returns the xid of
  901.      the shell widget.  But the property change has to take place
  902.      on the edit widget in order for a PropertyNotify event to
  903.      be generated */
  904.       win = XtWindow (FRAME_X_TEXT_WIDGET (f));
  905. #if 0
  906.       win = XXRESOURCE (Fx_id_of_frame (frame))->xid;
  907. #endif
  908.     }
  909.  
  910.   /* parse the atom name, either a string or an actual atom */
  911.   if (STRINGP (name))
  912.     {
  913.       prop = XInternAtom (dpy, string_data (XSTRING (name)), False);
  914.     }
  915.   else if (XRESOURCEP (name))
  916.     {
  917.       if (XXRESOURCE (name)->type != XA_ATOM)
  918.     error ("Property must be an X-resource ATOM");
  919.       prop = XXRESOURCE (name)->xid;
  920.     }
  921.   else
  922.     error ("Property must be a string or X-resource ATOM");
  923.  
  924.   if (prop == None)
  925.     return Qnil;
  926.  
  927.   /* that's it. Now set it */
  928.   return raw_set_property (dpy, win, prop, value);
  929. }
  930.  
  931. /*
  932.  * Epoch equivalent:  epoch::send-client-message
  933.  */
  934. DEFUN ("x-send-client-message", Fx_send_client_message, Sx_send_client_message,
  935.        1, 5, 0,
  936.   "Send a client message to DEST, marking it as being from SOURCE.\n\
  937. The message is DATA of TYPE with FORMAT.  If TYPE and FORMAT are omitted,\n\
  938. they are deduced from DATA.  If SOURCE is nil, the current frame is used.")
  939.      (dest, source, data, type, format)
  940.      Lisp_Object dest, source, data, type, format;
  941. {
  942.   /* !!#### This function has not been Mule-ized */
  943.   int actual_format = 0;
  944.   Atom actual_type;
  945.   unsigned long count;
  946.   void *addr;
  947.   int free_storage;
  948.   XEvent ev;
  949.   struct Lisp_X_Resource *xr;
  950.   Lisp_Object result;
  951.  
  952.   /* find our destination first */
  953.   if (XRESOURCEP (dest))
  954.     {
  955.       if (XXRESOURCE (dest)->type == XA_WINDOW)
  956.     xr = XXRESOURCE (dest);
  957.       else
  958.     error ("Argument must be a frame or x-window-resource");
  959.     }
  960.   else
  961.     {
  962.       xr = XXRESOURCE (Fx_id_of_frame (dest));
  963.     }
  964.  
  965.   /* find our source - all we need from this is the window id */
  966.   if (XRESOURCEP (source))
  967.     {
  968.       if (XXRESOURCE (source)->type != XA_WINDOW)
  969.     error ("X-resource must be a WINDOW");
  970.       ev.xclient.window = XXRESOURCE (source)->xid;
  971.     }
  972.   else
  973.     {
  974.       ev.xclient.window = XXRESOURCE (Fx_id_of_frame (source))->xid;
  975.     }
  976.  
  977.   /* check format before data, because it can cause the data format to vary */
  978.   if (!NILP (format))
  979.     {
  980.       CHECK_INT (format, 0);
  981.       actual_format = XINT (format);
  982.       if (actual_format != 8 && actual_format != 16 && actual_format != 32)
  983.     error ("Format must be 8, 16, or 32, or nil");
  984.     }
  985.  
  986.   /* clear out any cruft */
  987.   memset ((char *) &ev.xclient.data, 0, 20);
  988.  
  989.   /* look for the data */
  990.   if (!NILP (data))
  991.     {
  992.       convert_elisp_to_x (data, &addr, &count, &actual_type, &actual_format,
  993.               &free_storage);
  994.       if ((count * actual_format) > 20*8)
  995.     {
  996.       if (free_storage)
  997.         xfree (addr);
  998.       error ("Data is too big to fit in a client message");
  999.     }
  1000.       memmove (&ev.xclient.data, (char *)addr, count * (actual_format/8));
  1001.       if (free_storage)
  1002.     xfree (addr);
  1003.     }
  1004.  
  1005.   if (!NILP (type))
  1006.     {
  1007.       CHECK_XRESOURCE (type,0);
  1008.       if (XXRESOURCE (type)->type != XA_ATOM)
  1009.         error ("Resource for message type must be an atom");
  1010.       actual_type = XXRESOURCE (type)->xid;
  1011.     }
  1012.       
  1013.   ev.xany.type = ClientMessage;
  1014.   ev.xclient.message_type = actual_type;
  1015.   ev.xclient.format = actual_format;
  1016.   /* There's no better way to set the mask than to hard code the correct
  1017.    * width bit pattern. 1L<<24 == OwnerGrabButtonMask, is the largest
  1018.    * This is the word from the X-consortium.
  1019.    */
  1020.   result = (XSendEvent (FIXME_DISPLAY, xr->xid, False, (1L<<25)-1L,&ev)
  1021.         ? Qt
  1022.         : Qnil);
  1023.   XFlush (FIXME_DISPLAY);
  1024.   return result;
  1025. }
  1026.  
  1027. /*
  1028.  * These duplicate the needed functionality from the Epoch event handler.
  1029.  */
  1030. static Lisp_Object
  1031. read_client_message (XClientMessageEvent *cm)
  1032. {
  1033.   Lisp_Object result;
  1034.  
  1035.   if (!cm->format)    /* this is probably a sign of a bug somewhere else */
  1036.     result = Qnil;
  1037.   else
  1038.     result = Fcons (make_xresource (cm->message_type, XA_ATOM),
  1039.             Fcons (make_xresource (cm->window, XA_WINDOW),
  1040.                convert_x_to_elisp ((void *) cm->data.b,
  1041.                            (20*8)/cm->format,
  1042.                            cm->message_type,
  1043.                            cm->format)));
  1044.  
  1045.   return result;
  1046. }
  1047.  
  1048. static Lisp_Object
  1049. read_property_event (XPropertyEvent *pe, Lisp_Object frame)
  1050. {
  1051.   /* !!#### This function has not been Mule-ized */
  1052.   Lisp_Object result, value;
  1053.   struct frame *f = XFRAME (frame);
  1054.   Display *dpy = XtDisplay (FRAME_X_SHELL_WIDGET (f));
  1055.   char *atom_name;
  1056.  
  1057.   atom_name = XGetAtomName (dpy, pe->atom);
  1058.  
  1059.   /* didn't get a name, blow this one off */
  1060.   if (atom_name == (char *) 0)
  1061.     return Qnil;
  1062.  
  1063.   /* We can't use Fx_id_of_frame because it returns the xid of
  1064.      the shell widget.  But the property change has to take place
  1065.      on the edit widget in order for a PropertyNotify event to
  1066.      be generated */
  1067.   value = raw_get_property (dpy, XtWindow (FRAME_X_TEXT_WIDGET (f)),
  1068.                 pe->atom);
  1069.   result = Fcons (build_string (atom_name), value);
  1070.  
  1071.   xfree (atom_name);
  1072.  
  1073.   return result;
  1074. }
  1075.  
  1076. void
  1077. dispatch_epoch_event (XEvent *event, Lisp_Object type)
  1078. {
  1079.   /* This function can GC */
  1080.   struct Lisp_Vector *evp;
  1081.   struct frame *f;
  1082.  
  1083.   f = x_any_window_to_frame (get_device_from_display (event->xany.display),
  1084.                  eevent->xany.window);
  1085.   if (!f)
  1086.     {
  1087.       Vepoch_event = Qnil;
  1088.       return;
  1089.     }
  1090.  
  1091.   if (!VECTORP (Vepoch_event) || XVECTOR (Vepoch_event)->size < 3)
  1092.     Vepoch_event = Fmake_vector (make_number (3), Qnil);
  1093.   evp = XVECTOR (Vepoch_event);
  1094.  
  1095.   XSETFRAME (evp->contents[2], f);
  1096.  
  1097.   if (EQ (type, Qx_property_change))
  1098.     {
  1099.       evp->contents[0] = Qx_property_change;
  1100.       evp->contents[1] =
  1101.     read_property_event (&event->xproperty, evp->contents[2]);
  1102.     }
  1103.   else if (EQ (type, Qx_client_message))
  1104.     {
  1105.       evp->contents[0] = Qx_client_message;
  1106.       evp->contents[1] = read_client_message (&event->xclient);
  1107.     }
  1108.   else if (EQ (type, Qx_map))
  1109.     {
  1110.       evp->contents[0] = Qx_map;
  1111.       evp->contents[1] = Qt;
  1112.     }
  1113.   else if (EQ (type, Qx_unmap))
  1114.     {
  1115.       evp->contents[0] = Qx_unmap;
  1116.       evp->contents[1] = Qnil;
  1117.     }
  1118.   else
  1119.     {
  1120.       Vepoch_event = Qnil;
  1121.     }
  1122.  
  1123.   if (NILP (Vepoch_event))
  1124.     return;
  1125.   if (NILP (Vepoch_event_handler))
  1126.     return;
  1127.  
  1128.   Ffuncall (1, &Vepoch_event_handler);
  1129.  
  1130.   Vepoch_event = Qnil;
  1131.   return;
  1132. }
  1133.  
  1134. void
  1135. syms_of_epoch (void)
  1136. {
  1137.   defsubr (&Sx_intern_atom);
  1138.   defsubr (&Sx_atom_name);
  1139.   defsubr (&Sx_string_to_x_resource);
  1140.   defsubr (&Sx_resource_to_type);
  1141.   defsubr (&Sx_resource_to_string);
  1142.   defsubr (&Sx_id_of_frame);
  1143.   defsubr (&Sx_query_tree);
  1144.   defsubr (&Sx_get_property);
  1145.   defsubr (&Sx_set_property);
  1146.   defsubr (&Sx_send_client_message);
  1147.  
  1148.   defsymbol (&Qx_property_change, "x-property-change");
  1149.   defsymbol (&Qx_client_message, "x-client-message");
  1150.   defsymbol (&Qx_map, "x-map");
  1151.   defsymbol (&Qx_unmap, "x-unmap");
  1152. }
  1153.  
  1154. void
  1155. vars_of_epoch (void)
  1156. {
  1157.   Fprovide (intern ("epoch"));
  1158.  
  1159.   DEFVAR_LISP ("epoch-event-handler", &Vepoch_event_handler,
  1160.            "If this variable is not nil, then it is assumed to have\n\
  1161. a function in it.  When an epoch event is received for a frame, this\n\
  1162. function is called.");
  1163.   Vepoch_event_handler = Qnil;
  1164.  
  1165.   DEFVAR_LISP ("epoch-event", &Vepoch_event,
  1166.            "Bound to the value of the current event when epoch-event-handler is called.");
  1167.   Vepoch_event = Qnil;
  1168. }
  1169.